;; supercollider/uspec-compile.scm - (c) rohan drape, 2003-2005

;; Evaluates to a procedure of variable arity that constructs the UGen
;; described by the USpec `uspec'.  The first argument to the returned
;; procedure must be the UGen calculation rate.  Further arguments
;; specify the UGen inputs.  Each input may be any valid UGen input
;; object.  If there are fewer input arguments than inputs at the
;; UGen, the default values supplied by the USpec will be used.  If
;; any argument is a symbol naming an input, with an appended colon,
;; the subsequent value is written to that input.  

(define (uspec->procedure uspec)

  ;; Perform the replication that in SuperCollider is called
  ;; 'Multi-Channel Expansion'.  If any input at `inputs' is a list,
  ;; all inputs are expanded to lists equal in length to the longest
  ;; input, and a list of ugens are created, one for each element of
  ;; each input.  The resulting set of ugens is proxied possibly
  ;; resulting in a nested list.

  (define (new-ugen-proxied/expansion name rate 
				      inputs outputs special-index)

    ;; Create a new ugen object and evaluate to a list of
    ;; outputproxies that represent the ugen.  The ugen is not proxied
    ;; if it has zero or one outputs.
    
    (define (new-ugen-proxied name rate inputs outputs special-index)

      ;; Rewrite the list `inputs' replacing any lisp numbers with a
      ;; constant made from that number.

      (define (rewrite-lisp-constants inputs)
	(map (lambda (e)
	       (if (number? e) (make-constant e) e))
	     inputs))

      (let ((ugen (make-ugen name 
			     rate 
			     (rewrite-lisp-constants inputs)
			     (map make-output outputs) 
			     special-index))
	    (n (length outputs)))
	(if (< n 2)
	    ugen
	    (map (lambda (i)
		   (make-output-proxy ugen i))
		 (iota n)))))
    
    ;; Evaluate to the length of the longest list among the elements of
    ;; the list `inputs'.  Inputs that are not lists are said to be
    ;; lists of zero place, therefore a result of zero indicates
    ;; expansion to be unnecessary.  Input lists of zero places,
    ;; however, are illegal.

    (define (find-expansion-depth inputs)
      (if (= (length inputs) 0)
	  0
	  (apply
	   max
	   (map (lambda (e)
		  (if (list? e)
		      (let ((n (length e)))
			(if (= n 0)
			    (error "find-expansion-depth: no element list")
			    n))
		      0))
		inputs))))

    ;; Rewrite the list `inputs' so that all elements are lists of
    ;; length `n'.

    (define (expand-inputs inputs n)
      (map (lambda (e) (expand e n)) inputs))
    
    ;; Make a list that has the `n'th element of each list element of
    ;; the list `inputs'.

    (define (select-inputs expanded-inputs n)
      (map (lambda (e) (ref e n)) expanded-inputs))


    ;; If expansion is required each branch is treated recursively.

    (let ((expansion-depth (find-expansion-depth inputs)))
      (if (= expansion-depth 0)
	  (new-ugen-proxied name rate inputs outputs special-index)
	  (let ((expanded-inputs (expand-inputs inputs expansion-depth)))
	    (map (lambda (i)
		   (new-ugen-proxied/expansion
		    name 
		    rate 
		    (select-inputs expanded-inputs i)
		    outputs 
		    special-index))
		 (iota expansion-depth))))))

  ;; Examine `mul' and `add' and, if required, create and commit math
  ;; ugens so that the object returned is equal to '(incoming * mul) +
  ;; add'.  The value `incoming' is either a ugen or output-proxy object, or
  ;; a list of such.  The values `mul' and `add' are any ojects
  ;; acceptable as a ugen input value.

  (define (muladd-stage incoming rate mul add)

    ;; Evaluates to '#t' iff `value' is such that an mul or add operation
    ;; is required.  That is iff `value' is not a lisp number or
    ;; constant with a value of `identity', or a list of such.

    (define (muladd-required value identity)
      (cond ((list? value)
	     (index (lambda (e) (muladd-required e identity)) value))
	    (else
	     (if (or (and (number? value) (= value identity))
		     (and (constant? value) (= (constant-value value) identity)))
		 #f
		 #t))))

    (let ((mul-required (muladd-required mul 1.0))
	  (add-required (muladd-required add 0.0)))
      (if (and mul-required add-required)
	  (new-ugen-proxied/expansion
	   "MulAdd" 
	   rate 
	   (list incoming mul add) 
	   (list rate)
	   2)
	  (let ((after-mul (if mul-required
			       (new-ugen-proxied/expansion
				"BinaryOpUGen" 
				rate 
				(list incoming mul) 
				(list rate)
				(binop-index 'Mul))
			       incoming)))
	    (if add-required
		(new-ugen-proxied/expansion
		 "BinaryOpUGen" 
		 rate 
		 (list after-mul add) 
		 (list rate)
		 (binop-index 'Add))
		after-mul)))))

  ;; If `output-descriptor' is a number, evaluate to a list of a
  ;; length determined by consulting the list `inputs' at index
  ;; `output-descriptor', with `ugen-rate' at every location.  Else
  ;; evaluate to a list having the same elements as the list
  ;; `output-descriptor', however with each input element that is the
  ;; symbol 'ugen-rate' replaced by the value `ugen-rate'.

  (define (rewrite-output-descriptor inputs ugen-rate output-descriptor)
    (cond ((number? output-descriptor)
	   (let ((n (ref inputs (floorE output-descriptor))))
	     (if (number? n)
		 (make-list (floorE n) ugen-rate)
		 (error "rewrite-output-descriptor: output-descriptor"
			output-descriptor))))
	  ((list? output-descriptor)
	   (map (lambda (e) (if (eq? e 'ugen-rate) ugen-rate e)) 
		output-descriptor))
	  (else
	   (error "rewrite-output-descriptor: illegal output-descriptor"
		  output-descriptor))))

  ;; For variable channel output ugens, the output count is read from an
  ;; input, however this is removed before being sent to the ugen, since
  ;; it is not required there.

  (define (remove-output-indicator inputs output-descriptor)
    (if (number? output-descriptor)
	(remove-index 
	 (lambda (e) 
	   (= e (floorE output-descriptor)))
	 inputs)
	inputs))

  ;; Ugens that accept a variable number of inputs receive these as a
  ;; list argument, and this is noted in the default value for that
  ;; input.  For other inputs a list requires the ugen be expanded.
  ;; This procedure prepares the input list to be sent to the ugen
  ;; creator.  It first protects all non-list inputs, then removes the
  ;; output-indicator if one is provided, then flattens the resulting
  ;; list one level.

  (define (make-inputs-list ugen-inputs input-descriptor output-descriptor)
    (splice
     (remove-output-indicator 
      (map (lambda (input description)
	     (if (list? (cadr description))
		 input
		 (list input)))
	   ugen-inputs input-descriptor)
      output-descriptor)))

  (let* ((name (uspec-name/ugen uspec))
	 (input-descriptor (uspec-inputs uspec))
	 (output-descriptor (uspec-outputs uspec))
	 (special-index (uspec-special-index uspec))
	 (with-muladd (append input-descriptor '((mul 1.0) (add 0.0))))
	 (input-rewriter (lambdaK-rewriter name with-muladd)))
    (lambda (rate inputs)
      (let* ((inputs* (input-rewriter inputs))
	     (ugen-inputs (drop-right inputs* 2))
	     (mul+add (take-right inputs* 2)))
	(muladd-stage 
	 (new-ugen-proxied/expansion
	  name
	  rate
	  (make-inputs-list ugen-inputs input-descriptor output-descriptor)
	  (rewrite-output-descriptor ugen-inputs
				     rate
				     output-descriptor)
	  special-index)
	 rate 
	 (car mul+add)
	 (cadr mul+add))))))

;; Construct a list of s-expressions that make ugen procedures from
;; the USpec `s' and bind rate specializations of these procedures to
;; symbols with the appropriate rate suffixes.

(define (uspec-compile s)
  (define (generate name constructor rate)
    (let ((rate-string (ref '(".ir" ".kr" ".ar" ".dr") rate)))
      `(define ,(string->symbol (string-append name rate-string))
	 (let ((p ,constructor)) (lambda args (p ,rate args))))))
  (cons 
   `(define (,(string->symbol (string-append (uspec-name/constructor s) ".uspec"))) ',s)
   (let* ((n (uspec-name/constructor s))
	  (e `(uspec->procedure ',s)))
     (map (lambda (rate) (generate n e rate))
	  (uspec-rates s)))))

;; Write the SC3 class implementation of the USpec 's' to the current
;; output port.  Does not support variable output USpecs, however it
;; does raise an error...

(define (uspec->sc3-class-definition s)
  (define (write-normal-rate-constructor s c r)
    (display (format " *~ar { arg " c))
    (for-each
     (lambda (i)
       (display (format " ~a = ~a," 
			(uspec-input-name i)
			(uspec-input-default-value i))))
     (uspec-inputs s))
    (display* " mul = 1.0, add = 0.0;")
    (display (format "  ^this.multiNew('~a'" r))
    (for-each
     (lambda (i)
       (display (format ", ~a" (uspec-input-name i))))
     (uspec-inputs s))
    (display* ").madd(mul, add);")
    (display* " }"))
  (define (write-variable-input-rate-constructor s c r)
    (display (format " *~ar { arg " c))
    (for-each
     (lambda (i)
       (display (format " ~a = ~a," 
			(uspec-input-name i)
			(uspec-input-default-value i))))
     (drop-right (uspec-inputs s) 1))
    (display* (format " ~a ;" (uspec-input-name (last (uspec-inputs s)))))
    (display (format "  ^this.multiNewList(['~a'" r))
    (for-each
     (lambda (i)
       (display (format ", ~a" (uspec-input-name i))))
     (drop-right (uspec-inputs s) 1))
    (display* (format "] ++ ~a );" (uspec-input-name (last (uspec-inputs s)))))
    (display* " }"))
  (if (uspec-has-variable-outputs? s)
      (error "uspec->sc3-class-definition: not implemented for variable output USpecs"))
  (display* (format "~a : UGen {" (uspec-name/user s)))
  (let ((constructor (if (uspec-has-variable-inputs? s)
			 write-variable-input-rate-constructor
			 write-normal-rate-constructor)))
    (constructor s 'a 'audio)
    (constructor s 'k 'control)
    (display* "}")))
